home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _578a7e716d2bd16ca7de646aed40251e < prev    next >
Encoding:
Text File  |  2002-05-30  |  12.5 KB  |  540 lines
  1. # Converted from listbox.tcl --
  2. #
  3. # This file defines the default bindings for Tk listbox widgets.
  4. #
  5. # @(#) listbox.tcl 1.7 94/12/17 16:05:18
  6. #
  7. # Copyright (c) 1994 The Regents of the University of California.
  8. # Copyright (c) 1994 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  
  13. package Tk::Listbox;
  14.  
  15. use vars qw($VERSION);
  16. $VERSION = '3.031'; # $Id: //depot/Tk8/Listbox/Listbox.pm#31 $
  17.  
  18. use Tk qw(Ev $XS_VERSION);
  19. use Tk::Clipboard ();
  20. use AutoLoader;
  21.  
  22. use base  qw(Tk::Clipboard Tk::Widget);
  23.  
  24. Construct Tk::Widget 'Listbox';
  25.  
  26. bootstrap Tk::Listbox;
  27.  
  28. sub Tk_cmd { \&Tk::listbox }
  29.  
  30. Tk::Methods('activate','bbox','curselection','delete','get','index',
  31.             'insert','nearest','scan','see','selection','size',
  32.             'xview','yview');
  33.  
  34. use Tk::Submethods ( 'selection' => [qw(anchor clear includes set)],
  35.              'scan'      => [qw(mark dragto)],
  36.              'xview'     => [qw(moveto scroll)],
  37.              'yview'     => [qw(moveto scroll)],
  38.              );
  39.  
  40. *Getselected = \&getSelected;
  41.  
  42. sub clipEvents
  43. {
  44.  return qw[Copy];
  45. }
  46.  
  47. sub BalloonInfo
  48. {
  49.  my ($listbox,$balloon,$X,$Y,@opt) = @_;
  50.  my $e = $listbox->XEvent;
  51.  my $index = $listbox->index('@' . $e->x . ',' . $e->y);
  52.  foreach my $opt (@opt)
  53.   {
  54.    my $info = $balloon->GetOption($opt,$listbox);
  55.    if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
  56.     {
  57.      $balloon->Subclient($index);
  58.      if (defined $info->[$index])
  59.       {
  60.        return $info->[$index];
  61.       }
  62.      return '';
  63.     }
  64.    return $info;
  65.   }
  66. }
  67.  
  68. sub ClassInit
  69. {
  70.  my ($class,$mw) = @_;
  71.  $class->SUPER::ClassInit($mw);
  72.  # Standard Motif bindings:
  73.  $mw->bind($class,'<1>',['BeginSelect',Ev('index',Ev('@'))]);
  74.  $mw->bind($class,'<B1-Motion>',['Motion',Ev('index',Ev('@'))]);
  75.  $mw->bind($class,'<ButtonRelease-1>','ButtonRelease_1');
  76.  ;
  77.  $mw->bind($class,'<Shift-1>',['BeginExtend',Ev('index',Ev('@'))]);
  78.  $mw->bind($class,'<Control-1>',['BeginToggle',Ev('index',Ev('@'))]);
  79.  
  80.  $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x'),Ev('y')]);
  81.  $mw->bind($class,'<B1-Enter>','CancelRepeat');
  82.  $mw->bind($class,'<Up>',['UpDown',-1]);
  83.  $mw->bind($class,'<Shift-Up>',['ExtendUpDown',-1]);
  84.  $mw->bind($class,'<Down>',['UpDown',1]);
  85.  $mw->bind($class,'<Shift-Down>',['ExtendUpDown',1]);
  86.  
  87.  $mw->XscrollBind($class);
  88.  $mw->PriorNextBind($class);
  89.  
  90.  $mw->bind($class,'<Control-Home>','Cntrl_Home');
  91.  ;
  92.  $mw->bind($class,'<Shift-Control-Home>',['DataExtend',0]);
  93.  $mw->bind($class,'<Control-End>','Cntrl_End');
  94.  ;
  95.  $mw->bind($class,'<Shift-Control-End>',['DataExtend','end']);
  96.  # $class->clipboardOperations($mw,'Copy');
  97.  $mw->bind($class,'<space>',['BeginSelect',Ev('index','active')]);
  98.  $mw->bind($class,'<Select>',['BeginSelect',Ev('index','active')]);
  99.  $mw->bind($class,'<Control-Shift-space>',['BeginExtend',Ev('index','active')]);
  100.  $mw->bind($class,'<Shift-Select>',['BeginExtend',Ev('index','active')]);
  101.  $mw->bind($class,'<Escape>','Cancel');
  102.  $mw->bind($class,'<Control-slash>','SelectAll');
  103.  $mw->bind($class,'<Control-backslash>','Cntrl_backslash');
  104.  ;
  105.  # Additional Tk bindings that aren't part of the Motif look and feel:
  106.  $mw->bind($class,'<2>',['scan','mark',Ev('x'),Ev('y')]);
  107.  $mw->bind($class,'<B2-Motion>',['scan','dragto',Ev('x'),Ev('y')]);
  108.  return $class;
  109. }
  110.  
  111. 1;
  112. __END__
  113.  
  114. #
  115. # Bind --
  116. # This procedure is invoked the first time the mouse enters a listbox
  117. # widget or a listbox widget receives the input focus. It creates
  118. # all of the class bindings for listboxes.
  119. #
  120. # Arguments:
  121. # event - Indicates which event caused the procedure to be invoked
  122. # (Enter or FocusIn). It is used so that we can carry out
  123. # the functions of that event in addition to setting up
  124. # bindings.
  125.  
  126. sub xyIndex
  127. {
  128.  my $w = shift;
  129.  my $Ev = $w->XEvent;
  130.  return $w->index($Ev->xy);
  131. }
  132.  
  133. sub ButtonRelease_1
  134. {
  135.  my $w = shift;
  136.  my $Ev = $w->XEvent;
  137.  $w->CancelRepeat;
  138.  $w->activate($Ev->xy);
  139. }
  140.  
  141.  
  142. sub Cntrl_Home
  143. {
  144.  my $w = shift;
  145.  my $Ev = $w->XEvent;
  146.  $w->activate(0);
  147.  $w->see(0);
  148.  $w->selectionClear(0,'end');
  149.  $w->selectionSet(0)
  150. }
  151.  
  152.  
  153. sub Cntrl_End
  154. {
  155.  my $w = shift;
  156.  my $Ev = $w->XEvent;
  157.  $w->activate('end');
  158.  $w->see('end');
  159.  $w->selectionClear(0,'end');
  160.  $w->selectionSet('end')
  161. }
  162.  
  163.  
  164. sub Cntrl_backslash
  165. {
  166.  my $w = shift;
  167.  my $Ev = $w->XEvent;
  168.  if ($w->cget('-selectmode') ne 'browse')
  169.  {
  170.  $w->selectionClear(0,'end');
  171.  }
  172. }
  173.  
  174. # BeginSelect --
  175. #
  176. # This procedure is typically invoked on button-1 presses. It begins
  177. # the process of making a selection in the listbox. Its exact behavior
  178. # depends on the selection mode currently in effect for the listbox;
  179. # see the Motif documentation for details.
  180. #
  181. # Arguments:
  182. # w - The listbox widget.
  183. # el - The element for the selection operation (typically the
  184. # one under the pointer). Must be in numerical form.
  185. sub BeginSelect
  186. {
  187.  my $w = shift;
  188.  my $el = shift;
  189.  if ($w->cget('-selectmode') eq 'multiple')
  190.   {
  191.    if ($w->selectionIncludes($el))
  192.     {
  193.      $w->selectionClear($el)
  194.     }
  195.    else
  196.     {
  197.      $w->selectionSet($el)
  198.     }
  199.   }
  200.  else
  201.   {
  202.    $w->selectionClear(0,'end');
  203.    $w->selectionSet($el);
  204.    $w->selectionAnchor($el);
  205.    @Selection = ();
  206.    $Prev = $el
  207.   }
  208.  $w->focus if ($w->cget('-takefocus'));
  209. }
  210. # Motion --
  211. #
  212. # This procedure is called to process mouse motion events while
  213. # button 1 is down. It may move or extend the selection, depending
  214. # on the listbox's selection mode.
  215. #
  216. # Arguments:
  217. # w - The listbox widget.
  218. # el - The element under the pointer (must be a number).
  219. sub Motion
  220. {
  221.  my $w = shift;
  222.  my $el = shift;
  223.  if (defined($Prev) && $el == $Prev)
  224.   {
  225.    return;
  226.   }
  227.  $anchor = $w->index('anchor');
  228.  my $mode = $w->cget('-selectmode');
  229.  if ($mode eq 'browse')
  230.   {
  231.    $w->selectionClear(0,'end');
  232.    $w->selectionSet($el);
  233.    $Prev = $el;
  234.   }
  235.  elsif ($mode eq 'extended')
  236.   {
  237.    $i = $Prev;
  238.    if ($w->selectionIncludes('anchor'))
  239.     {
  240.      $w->selectionClear($i,$el);
  241.      $w->selectionSet('anchor',$el)
  242.     }
  243.    else
  244.     {
  245.      $w->selectionClear($i,$el);
  246.      $w->selectionClear('anchor',$el)
  247.     }
  248.    while ($i < $el && $i < $anchor)
  249.     {
  250.      if (Tk::lsearch(\@Selection,$i) >= 0)
  251.       {
  252.        $w->selectionSet($i)
  253.       }
  254.      $i += 1
  255.     }
  256.    while ($i > $el && $i > $anchor)
  257.     {
  258.      if (Tk::lsearch(\@Selection,$i) >= 0)
  259.       {
  260.        $w->selectionSet($i)
  261.       }
  262.      $i += -1
  263.     }
  264.    $Prev = $el
  265.   }
  266. }
  267. # BeginExtend --
  268. #
  269. # This procedure is typically invoked on shift-button-1 presses. It
  270. # begins the process of extending a selection in the listbox. Its
  271. # exact behavior depends on the selection mode currently in effect
  272. # for the listbox; see the Motif documentation for details.
  273. #
  274. # Arguments:
  275. # w - The listbox widget.
  276. # el - The element for the selection operation (typically the
  277. # one under the pointer). Must be in numerical form.
  278. sub BeginExtend
  279. {
  280.  my $w = shift;
  281.  my $el = shift;
  282.  if ($w->cget('-selectmode') eq 'extended' && $w->selectionIncludes('anchor'))
  283.   {
  284.    $w->Motion($el)
  285.   }
  286. }
  287. # BeginToggle --
  288. #
  289. # This procedure is typically invoked on control-button-1 presses. It
  290. # begins the process of toggling a selection in the listbox. Its
  291. # exact behavior depends on the selection mode currently in effect
  292. # for the listbox; see the Motif documentation for details.
  293. #
  294. # Arguments:
  295. # w - The listbox widget.
  296. # el - The element for the selection operation (typically the
  297. # one under the pointer). Must be in numerical form.
  298. sub BeginToggle
  299. {
  300.  my $w = shift;
  301.  my $el = shift;
  302.  if ($w->cget('-selectmode') eq 'extended')
  303.   {
  304.    @Selection = $w->curselection();
  305.    $Prev = $el;
  306.    $w->selectionAnchor($el);
  307.    if ($w->selectionIncludes($el))
  308.     {
  309.      $w->selectionClear($el)
  310.     }
  311.    else
  312.     {
  313.      $w->selectionSet($el)
  314.     }
  315.   }
  316. }
  317. # AutoScan --
  318. # This procedure is invoked when the mouse leaves an entry window
  319. # with button 1 down. It scrolls the window up, down, left, or
  320. # right, depending on where the mouse left the window, and reschedules
  321. # itself as an "after" command so that the window continues to scroll until
  322. # the mouse moves back into the window or the mouse button is released.
  323. #
  324. # Arguments:
  325. # w - The entry window.
  326. # x - The x-coordinate of the mouse when it left the window.
  327. # y - The y-coordinate of the mouse when it left the window.
  328. sub AutoScan
  329. {
  330.  my $w = shift;
  331.  my $x = shift;
  332.  my $y = shift;
  333.  if ($y >= $w->height)
  334.   {
  335.    $w->yview('scroll',1,'units')
  336.   }
  337.  elsif ($y < 0)
  338.   {
  339.    $w->yview('scroll',-1,'units')
  340.   }
  341.  elsif ($x >= $w->width)
  342.   {
  343.    $w->xview('scroll',2,'units')
  344.   }
  345.  elsif ($x < 0)
  346.   {
  347.    $w->xview('scroll',-2,'units')
  348.   }
  349.  else
  350.   {
  351.    return;
  352.   }
  353.  $w->Motion($w->index("@" . $x . ',' . $y));
  354.  $w->RepeatId($w->after(50,'AutoScan',$w,$x,$y));
  355. }
  356. # UpDown --
  357. #
  358. # Moves the location cursor (active element) up or down by one element,
  359. # and changes the selection if we're in browse or extended selection
  360. # mode.
  361. #
  362. # Arguments:
  363. # w - The listbox widget.
  364. # amount - +1 to move down one item, -1 to move back one item.
  365. sub UpDown
  366. {
  367.  my $w = shift;
  368.  my $amount = shift;
  369.  $w->activate($w->index('active')+$amount);
  370.  $w->see('active');
  371.  $LNet__0 = $w->cget('-selectmode');
  372.  if ($LNet__0 eq 'browse')
  373.   {
  374.    $w->selectionClear(0,'end');
  375.    $w->selectionSet('active')
  376.   }
  377.  elsif ($LNet__0 eq 'extended')
  378.   {
  379.    $w->selectionClear(0,'end');
  380.    $w->selectionSet('active');
  381.    $w->selectionAnchor('active');
  382.    $Prev = $w->index('active');
  383.    @Selection = ();
  384.   }
  385. }
  386. # ExtendUpDown --
  387. #
  388. # Does nothing unless we're in extended selection mode; in this
  389. # case it moves the location cursor (active element) up or down by
  390. # one element, and extends the selection to that point.
  391. #
  392. # Arguments:
  393. # w - The listbox widget.
  394. # amount - +1 to move down one item, -1 to move back one item.
  395. sub ExtendUpDown
  396. {
  397.  my $w = shift;
  398.  my $amount = shift;
  399.  if ($w->cget('-selectmode') ne 'extended')
  400.   {
  401.    return;
  402.   }
  403.  $w->activate($w->index('active')+$amount);
  404.  $w->see('active');
  405.  $w->Motion($w->index('active'))
  406. }
  407. # DataExtend
  408. #
  409. # This procedure is called for key-presses such as Shift-KEndData.
  410. # If the selection mode isn't multiple or extend then it does nothing.
  411. # Otherwise it moves the active element to el and, if we're in
  412. # extended mode, extends the selection to that point.
  413. #
  414. # Arguments:
  415. # w - The listbox widget.
  416. # el - An integer element number.
  417. sub DataExtend
  418. {
  419.  my $w = shift;
  420.  my $el = shift;
  421.  $mode = $w->cget('-selectmode');
  422.  if ($mode eq 'extended')
  423.   {
  424.    $w->activate($el);
  425.    $w->see($el);
  426.    if ($w->selectionIncludes('anchor'))
  427.     {
  428.      $w->Motion($el)
  429.     }
  430.   }
  431.  elsif ($mode eq 'multiple')
  432.   {
  433.    $w->activate($el);
  434.    $w->see($el)
  435.   }
  436. }
  437. # Cancel
  438. #
  439. # This procedure is invoked to cancel an extended selection in
  440. # progress. If there is an extended selection in progress, it
  441. # restores all of the items between the active one and the anchor
  442. # to their previous selection state.
  443. #
  444. # Arguments:
  445. # w - The listbox widget.
  446. sub Cancel
  447. {
  448.  my $w = shift;
  449.  if ($w->cget('-selectmode') ne 'extended' || !defined $Prev)
  450.   {
  451.    return;
  452.   }
  453.  $first = $w->index('anchor');
  454.  $last = $Prev;
  455.  if ($first > $last)
  456.   {
  457.    $tmp = $first;
  458.    $first = $last;
  459.    $last = $tmp
  460.   }
  461.  $w->selectionClear($first,$last);
  462.  while ($first <= $last)
  463.   {
  464.    if (Tk::lsearch(\@Selection,$first) >= 0)
  465.     {
  466.      $w->selectionSet($first)
  467.     }
  468.    $first += 1
  469.   }
  470. }
  471. # SelectAll
  472. #
  473. # This procedure is invoked to handle the "select all" operation.
  474. # For single and browse mode, it just selects the active element.
  475. # Otherwise it selects everything in the widget.
  476. #
  477. # Arguments:
  478. # w - The listbox widget.
  479. sub SelectAll
  480. {
  481.  my $w = shift;
  482.  my $mode = $w->cget('-selectmode');
  483.  if ($mode eq 'single' || $mode eq 'browse')
  484.   {
  485.    $w->selectionClear(0,'end');
  486.    $w->selectionSet('active')
  487.   }
  488.  else
  489.   {
  490.    $w->selectionSet(0,'end')
  491.   }
  492. }
  493.  
  494. sub SetList
  495. {
  496.  my $w = shift;
  497.  $w->delete(0,'end');
  498.  $w->insert('end',@_);
  499. }
  500.  
  501. sub deleteSelected
  502. {
  503.  my $w = shift;
  504.  my $i;
  505.  foreach $i (reverse $w->curselection)
  506.   {
  507.    $w->delete($i);
  508.   }
  509. }
  510.  
  511. sub clipboardPaste
  512. {
  513.  my $w = shift;
  514.  my $index = $w->index('active') || $w->index($w->XEvent->xy);
  515.  my $str;
  516.  eval {local $SIG{__DIE__}; $str = $w->clipboardGet };
  517.  return if $@;
  518.  foreach (split("\n",$str))
  519.   {
  520.    $w->insert($index++,$_);
  521.   }
  522. }
  523.  
  524. sub getSelected
  525. {
  526.  my ($w) = @_;
  527.  my $i;
  528.  my (@result) = ();
  529.  foreach $i ($w->curselection)
  530.   {
  531.    push(@result,$w->get($i));
  532.   }
  533.  return (wantarray) ? @result : $result[0];
  534. }
  535.  
  536.  
  537.  
  538. 1;
  539. __END__
  540.